home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / Pascal / Applications / TCPExample / PNL Libraries / MyStrings.p < prev    next >
Encoding:
Text File  |  1997-07-16  |  14.4 KB  |  632 lines  |  [TEXT/CWIE]
  1. unit MyStrings;
  2.  
  3. interface
  4.  
  5.     uses
  6.         Types, MyTypes;
  7.  
  8.     procedure LeftP (var s: Str255; len: integer);
  9.     function LeftF (var s: Str255; len: integer): Str255;
  10.     procedure LeftAssignP (var s: Str255; len: integer; var rhs: Str255);
  11.     function LeftAssign (var s: Str255; len: integer; var rhs: Str255): Str255;
  12.     procedure RightP (var s: Str255; len: integer);
  13.     function RightF (var s: Str255; len: integer): Str255;
  14.     procedure RightAssignP (var s: Str255; len: integer; var rhs: Str255);
  15.     function RightAssign (var s: Str255; len: integer; var rhs: Str255): Str255;
  16.     procedure MidP (var s: Str255; p, len: integer);
  17.     function Mid (var s: Str255; p, len: integer): Str255;
  18.     procedure MidAssignP (var s: Str255; p, len: integer; const rhs: Str255);
  19.     function MidAssign (const s: Str255; p, len: integer; const rhs: Str255): Str255;
  20.     procedure HandleToString (hhhh: univ Handle; var s: Str255);
  21.     function HandleToStr (hhhh: univ Handle): Str255;
  22.     procedure StringToHandle (const s: Str255; hhhh: univ Handle);
  23.     function Trim (s: string): string;
  24.     function LowerCase( ch: char ): char;
  25.     function UpCaseChar (ch: char): char;
  26. {$IFC not GENERATINGPOWERPC}
  27.     inline
  28.         $301F, $0C00, $0061, $6500, $000E, $0C00, $007B, $6400, $0006, $0400, $0020, $3E80;
  29. {$ENDC}
  30.     function IsDigit(ch:char):boolean;
  31. {$IFC not GENERATINGPOWERPC}
  32.     inline
  33.         $321F,$0C41,$0030,$5CC0,$6D08,$0C41,$0039,$6F02,$5FC0,$4400,$1E80;
  34. {$ENDC}
  35.     function IsLower(ch:char):boolean;
  36. {$IFC not GENERATINGPOWERPC}
  37.     inline
  38.         $321F,$0C41,$0061,$5CC0,$6D08,$0C41,$007A,$6F02,$5FC0,$4400,$1E80;
  39. {$ENDC}
  40.     function IsUpper(ch:char):boolean;
  41. {$IFC not GENERATINGPOWERPC}
  42.     inline
  43.         $321F,$0C41,$0041,$5CC0,$6D08,$0C41,$005A,$6F02,$5FC0,$4400,$1E80;
  44. {$ENDC}
  45.     function IsAlpha(ch:char):boolean;
  46. {$IFC not GENERATINGPOWERPC}
  47.     inline
  48.         $321F,$0C41,$0041,$5CC0,$6D16,$0C41,$005A,$6F10,$0C41,$0061,$5CC0,$6D08,$0C41,$007A,$6F02,$5FC0,$4400,$1E80;
  49. {$ENDC}
  50.  
  51.     procedure UpCaseString (var s: string);
  52.     function UpCaseStr (s: string): string;
  53.     procedure LowerCaseString (var s: string);
  54.     function LowerCaseStr (s: string): string;
  55.     
  56.     function NoCaseEquals( s1, s2: string ): boolean;
  57.     function NoCasePos( s1, s2: string ): integer;
  58.     
  59.     procedure SPrintS5 (var dst: Str255; const src, s1, s2, s3, s4, s5: Str255);
  60.     procedure SPrintS3 (var dst: Str255; const src, s1, s2, s3: Str255);
  61.     
  62.     function PosRight (sub: char; const s: Str255): integer;
  63.     function PosRightStr (const sub, s: Str255): integer;
  64.     function Contains( sub: char; const s: Str255 ): boolean;
  65.     function ContainsStr( const sub, s: Str255 ): boolean;
  66.     procedure SplitBy (s: Str255; sub: char; var left, right: Str255);
  67.     procedure SplitRightBy (s: Str255; sub: char; var left, right: Str255);
  68.     procedure SplitByStr (s: Str255; const sub: Str255; var left, right: Str255);
  69.     procedure SplitRightByStr (s: Str255; const sub: Str255; var left, right: Str255);
  70.     function SplitAt (s: Str255; sub: char; var s1, s2: Str255): boolean;
  71.     function SplitRightAt(s: Str255; sub: char; var s1, s2: Str255): boolean;
  72.     function SplitAtStr (s: Str255; const sub: Str255; var s1, s2: Str255): boolean;
  73.     function SplitRightAtStr (s: Str255; const sub: Str255; var s1, s2: Str255): boolean;
  74. {    function Pos (sub, str: string): integer;}
  75.     function TPcopy (source: string; start, count: integer): string;
  76.     
  77.     function Match (pattern, name: Str255): boolean;
  78.     procedure LimitStringLength (var s: string; len: integer; delimiter: char);
  79.     function StringToOSType (const s: Str255): OSType;
  80.     function OSTypeToString (t: OSType): Str255;
  81.     function FindCharacter(p:Ptr; len:longint; ch:Char; var pos:longint):boolean;
  82.  
  83. implementation
  84.  
  85.     uses
  86.         Memory, OSUtils, TextUtils, MyMathUtils, MyLowLevel, MyMemory;
  87.  
  88.     function FindCharacter(p:Ptr; len:longint; ch:Char; var pos:longint):boolean;
  89.     begin
  90.         pos:=0;
  91.         while (pos<len) & (AddPtrLong(p,pos)^<>ord(ch)) do begin
  92.             pos:=pos+1;
  93.         end;
  94.         FindCharacter:= pos<len;
  95.     end;
  96.     
  97.     procedure LeftP (var s: Str255; len: integer);
  98.     begin
  99.         s := TPcopy(s, 1, len);
  100.     end;
  101.  
  102.     function LeftF (var s: Str255; len: integer): Str255;
  103.     begin
  104.         LeftF := TPcopy(s, 1, len);
  105.     end;
  106.  
  107.     procedure LeftAssignP (var s: Str255; len: integer; var rhs: Str255);
  108.     begin
  109.         s := concat(rhs, TPcopy(s, len + 1, 255));
  110.     end;
  111.  
  112.     function LeftAssign (var s: Str255; len: integer; var rhs: Str255): Str255;
  113.     begin
  114.         LeftAssign := concat(rhs, TPcopy(s, len + 1, 255));
  115.     end;
  116.  
  117.     procedure RightP (var s: Str255; len: integer);
  118.         var
  119.             p: integer;
  120.     begin
  121.         p := Length(s) - len;
  122.         if p < 1 then begin
  123.             p := 1;
  124.         end;
  125.         s := TPcopy(s, p, 255);
  126.     end;
  127.  
  128.     function RightF (var s: Str255; len: integer): Str255;
  129.         var
  130.             p: integer;
  131.     begin
  132.         p := Length(s) - len;
  133.         if p < 1 then begin
  134.             p := 1;
  135.         end;
  136.         RightF := TPcopy(s, p, 255);
  137.     end;
  138.  
  139.     procedure RightAssignP (var s: Str255; len: integer; var rhs: Str255);
  140.     begin
  141.         s := concat(TPcopy(s, 1, Length(s) - len), rhs);
  142.     end;
  143.  
  144.     function RightAssign (var s: Str255; len: integer; var rhs: Str255): Str255;
  145.     begin
  146.         RightAssign := concat(TPcopy(s, 1, Length(s) - len), rhs);
  147.     end;
  148.  
  149.     procedure MidP (var s: Str255; p, len: integer);
  150.     begin
  151.         s := TPcopy(s, p, len);
  152.     end;
  153.  
  154.     function Mid (var s: Str255; p, len: integer): Str255;
  155.     begin
  156.         Mid := TPcopy(s, p, len);
  157.     end;
  158.  
  159.     procedure MidAssignP (var s: Str255; p, len: integer; const rhs: Str255);
  160.     begin
  161.         s := concat(TPcopy(s, 1, p - 1), rhs, TPcopy(s, p + len, 255));
  162.     end;
  163.  
  164.     function MidAssign (const s: Str255; p, len: integer; const rhs: Str255): Str255;
  165.     begin
  166.         MidAssign := concat(TPcopy(s, 1, p - 1), rhs, TPcopy(s, p + len, 255));
  167.     end;
  168.  
  169. {$PUSH}
  170. {$R-}
  171.     procedure HandleToString (hhhh: univ Handle; var s: Str255);
  172.         var
  173.             len: longint;
  174.     begin
  175.         len := Min(255, MGetHandleSize(hhhh));
  176.         s[0] := chr(len);
  177.         BlockMoveData(hhhh^, @s[1], len);
  178.     end;
  179. {$POP}
  180.  
  181.     function HandleToStr (hhhh: univ Handle): Str255;
  182.         var
  183.             s: Str255;
  184.     begin
  185.         HandleToString(hhhh, s);
  186.         HandleToStr := s;
  187.     end;
  188.  
  189.     procedure StringToHandle (const s: Str255; hhhh: univ Handle);
  190.     begin
  191.         SetHandleSize(hhhh, length(s));
  192.         if (MemError = noErr) & (length(s) > 0) then begin
  193.             BlockMoveData(@s[1], hhhh^, length(s));
  194.         end;
  195.     end;
  196.  
  197.     function Trim (s: string): string;
  198.     begin
  199.         while (length(s) > 0) and (s[1] in [spc, tab, cr, lf]) do begin
  200.             Delete(s, 1, 1);
  201.         end;
  202.         while (length(s) > 0) and (s[length(s)] in [spc, tab, cr, lf]) do begin
  203.             Delete(s, length(s), 1);
  204.         end;
  205.         Trim := s;
  206.     end;
  207.  
  208.     function LowerCase( ch: char ): char;
  209.     begin
  210.         if ('A' <= ch) & (ch <= 'Z') then begin
  211.             ch := chr(ord(ch) + $20);
  212.         end;
  213.         LowerCase := ch;
  214.     end;
  215.  
  216. {$IFC GENERATINGPOWERPC}
  217.     function UpCaseChar (ch: char): char;
  218.     begin
  219.         if ('a' <= ch) & (ch <= 'z') then begin
  220.             ch := chr(ord(ch) - $20);
  221.         end;
  222.         UpCaseChar := ch;
  223.     end;
  224.  
  225.     function IsDigit(ch:char):boolean;
  226.     begin
  227.         IsDigit:=('0'<=ch) & (ch<='9');
  228.     end;
  229.     
  230.     function IsLower(ch:char):boolean;
  231.     begin
  232.         IsLower:=('a'<=ch) & (ch<='z');
  233.     end;
  234.     
  235.     function IsUpper(ch:char):boolean;
  236.     begin
  237.         IsUpper:=('A'<=ch) & (ch<='Z');
  238.     end;
  239.     
  240.     function IsAlpha(ch:char):boolean;
  241.     begin
  242.         IsAlpha:=(('a'<=ch) & (ch<='z')) | (('A'<=ch) & (ch<='Z'));
  243.     end;
  244. {$ENDC}
  245.  
  246.     function NoCaseEquals( s1, s2: string ): boolean;
  247.     begin
  248.         LowerCaseString( s1 );
  249.         LowerCaseString( s2 );
  250.         NoCaseEquals := s1 = s2;
  251.     end;
  252.  
  253.     function NoCasePos( s1, s2: string ): integer;
  254.     begin
  255.         LowerCaseString( s1 );
  256.         LowerCaseString( s2 );
  257.         NoCasePos := Pos( s1, s2 );
  258.     end;
  259.     
  260.     procedure LowerCaseString (var s: string);
  261.         var
  262.             i: integer;
  263.     begin
  264.         for i := 1 to length(s) do begin
  265.             s[i] := LowerCase(s[i]);
  266.         end;
  267.     end;
  268.  
  269.     function LowerCaseStr (s: string): string;
  270.         var
  271.             i: integer;
  272.     begin
  273.         for i := 1 to length(s) do begin
  274.             s[i] := LowerCase(s[i]);
  275.         end;
  276.         LowerCaseStr := s;
  277.     end;
  278.     
  279.     procedure UpCaseString (var s: string);
  280.         var
  281.             i: integer;
  282.     begin
  283.         for i := 1 to length(s) do begin
  284.             s[i] := UpCaseChar(s[i]);
  285.         end;
  286.     end;
  287.  
  288.     function UpCaseStr (s: string): string;
  289.         var
  290.             i: integer;
  291.     begin
  292.         for i := 1 to length(s) do begin
  293.             s[i] := UpCaseChar(s[i]);
  294.         end;
  295.         UpCaseStr := s;
  296.     end;
  297.  
  298.     function TPcopy (source: string; start, count: integer): string;
  299.     begin
  300.         if (start < 1) then begin
  301.             count := count - (1 - start);
  302.             start := 1;
  303.         end;
  304.         if start + count > length(source) then begin
  305.             count := length(source) - start + 1;
  306.         end;
  307.         if count < 0 then begin
  308.             count := 0;
  309.         end;
  310.         source[0] := chr(count);
  311.         BlockMoveData(@source[start], @source[1], count);
  312.         TPcopy := source;
  313.     end;
  314. {
  315.     function Pos (sub, str: string): integer;
  316.         var
  317.             i, j, ret: integer;
  318.     begin
  319.         i := 1;
  320.         ret := 1;
  321.         if length(sub) > 0 then begin
  322.             ret := 0;
  323.             while (i <= length(str) - length(sub) + 1) do begin
  324.                 if str[i] = sub[1] then begin
  325.                     j:=2;
  326.                     while j<=length(sub) do begin
  327.                         if str[i+j-1]<>sub[j] then begin
  328.                             leave;
  329.                         end;
  330.                         j:=j+1;
  331.                     end;
  332.                     if j>length(sub) then begin
  333.                         ret:=i;
  334.                         leave;
  335.                     end;
  336.                 end;
  337.                 i := i + 1;
  338.             end;
  339.         end;
  340.         Pos := ret;
  341.     end;
  342.  
  343. }    procedure DoSub (var dst: Str255; n: integer; const s: Str255);
  344.         var
  345.             p: integer;
  346.     begin
  347.         p := Pos(concat('^', chr(n + 48)), dst);
  348.         if p > 0 then begin
  349.             Delete(dst, p, 2);
  350.             Insert(s, dst, p);
  351.         end;
  352.     end;
  353.  
  354.     procedure SPrintS5 (var dst: Str255; const src, s1, s2, s3, s4, s5: Str255);
  355.         var
  356.             temp: Str255;
  357.     begin
  358.         temp := src;
  359.         DoSub(temp, 5, s5);
  360.         DoSub(temp, 4, s4);
  361.         DoSub(temp, 3, s3);
  362.         DoSub(temp, 2, s2);
  363.         DoSub(temp, 1, s1);
  364.         dst := temp;
  365.     end;
  366.  
  367.     procedure SPrintS3 (var dst: Str255; const src, s1, s2, s3: Str255);
  368.         var
  369.             temp: Str255;
  370.     begin
  371.         temp := src;
  372.         DoSub(temp, 3, s3);
  373.         DoSub(temp, 2, s2);
  374.         DoSub(temp, 1, s1);
  375.         dst := temp;
  376.     end;
  377.  
  378.     function PosRight (sub: char; const s: Str255): integer;
  379.         var
  380.             p: integer;
  381.     begin
  382.         p := length(s);
  383.         while p > 0 do begin
  384.             if s[p] = sub then begin
  385.                 leave;
  386.             end;
  387.             Dec(p);
  388.         end;
  389.         PosRight := p;
  390.     end;
  391.  
  392.     function PosRightStr (const sub, s: Str255): integer;
  393.         var
  394.             p, q: integer;
  395.     begin
  396.         p := Pos(sub, s);
  397.         if p > 0 then begin
  398.             q := length(s) - length(sub) + 1;
  399.             while q > p do begin
  400.                 if TPcopy(s, q, length(sub)) = sub then begin
  401.                     p := q;
  402.                 end else begin
  403.                     q := q - 1;
  404.                 end;
  405.             end;
  406.         end;
  407.         PosRightStr := p;
  408.     end;
  409.     
  410.     function Contains( sub: char; const s: Str255 ): boolean;
  411.     begin
  412.         Contains := Pos( sub, s ) > 0;
  413.     end;
  414.  
  415.     function ContainsStr( const sub, s: Str255 ): boolean;
  416.     begin
  417.         ContainsStr := Pos( sub, s ) > 0;
  418.     end;
  419.  
  420.     procedure SplitBy (s: Str255; sub: char; var left, right: Str255);
  421.         var
  422.             p: integer;
  423.     begin
  424.         p := Pos(sub, s);
  425.         if p <= 0 then begin
  426.             left := s;
  427.             right := '';
  428.         end else begin
  429.             left := TPcopy(s, 1, p - 1);
  430.             right := TPcopy(s, p + 1, 255);
  431.         end;
  432.     end;
  433.  
  434.     procedure SplitRightBy (s: Str255; sub: char; var left, right: Str255);
  435.         var
  436.             p: integer;
  437.     begin
  438.         p := PosRight(sub, s);
  439.         if p <= 0 then begin
  440.             left := '';
  441.             right := s;
  442.         end else begin
  443.             left := TPcopy(s, 1, p - 1);
  444.             right := TPcopy(s, p + 1, 255);
  445.         end;
  446.     end;
  447.  
  448.     procedure SplitByStr (s: Str255; const sub: Str255; var left, right: Str255);
  449.         var
  450.             p: integer;
  451.     begin
  452.         p := Pos(sub, s);
  453.         if p <= 0 then begin
  454.             left := s;
  455.             right := '';
  456.         end else begin
  457.             left := TPcopy(s, 1, p - 1);
  458.             right := TPcopy(s, p + 1, 255);
  459.         end;
  460.     end;
  461.  
  462.     procedure SplitRightByStr (s: Str255; const sub: Str255; var left, right: Str255);
  463.         var
  464.             p: integer;
  465.     begin
  466.         p := PosRightStr(sub, s);
  467.         if p <= 0 then begin
  468.             left := '';
  469.             right := s;
  470.         end else begin
  471.             left := TPcopy(s, 1, p - 1);
  472.             right := TPcopy(s, p + 1, 255);
  473.         end;
  474.     end;
  475.  
  476.     function SplitAt (s: Str255; sub: char; var s1, s2: Str255): boolean;
  477.         var
  478.             p: integer;
  479.     begin
  480.         p := Pos(sub, s);
  481.         if p > 0 then begin
  482.             s1 := TPcopy(s, 1, p - 1);
  483.             s2 := TPcopy(s, p + 1, 255);
  484.         end;
  485.         SplitAt := p > 0;
  486.     end;
  487.  
  488.     function SplitRightAt(s: Str255; sub: char; var s1, s2: Str255): boolean;
  489.         var
  490.             p: integer;
  491.     begin
  492.         p := PosRight(sub, s);
  493.         if p > 0 then begin
  494.             s1 := TPcopy(s, 1, p - 1);
  495.             s2 := TPcopy(s, p + 1, 255);
  496.         end;
  497.         SplitRightAt := p > 0;
  498.     end;
  499.  
  500.     function SplitAtStr (s: Str255; const sub: Str255; var s1, s2: Str255): boolean;
  501.         var
  502.             p: integer;
  503.     begin
  504.         p := Pos(sub, s);
  505.         if p > 0 then begin
  506.             s1 := TPcopy(s, 1, p - 1);
  507.             s2 := TPcopy(s, p + length(sub), 255);
  508.         end;
  509.         SplitAtStr := p > 0;
  510.     end;
  511.  
  512.     function SplitRightAtStr (s: Str255; const sub: Str255; var s1, s2: Str255): boolean;
  513.         var
  514.             p: integer;
  515.     begin
  516.         p := PosRightStr(sub, s);
  517.         if p > 0 then begin
  518.             s1 := TPcopy(s, 1, p - 1);
  519.             s2 := TPcopy(s, p + length(sub), 255);
  520.         end;
  521.         SplitRightAtStr := p > 0;
  522.     end;
  523.  
  524.     function Match (pattern, name: Str255): boolean;
  525.         function M (p, n: integer): boolean;
  526.             var
  527.                 state: (searching, failed, success);
  528.         begin
  529.             state := searching;
  530.             while state = searching do begin
  531.                 case ord(p <= length(pattern)) * 2 + ord(n <= length(name)) of
  532.                     0:  begin
  533.                         state := success;
  534.                     end;
  535.                     1:  begin
  536.                         state := failed;
  537.                     end;
  538.                     2:  begin
  539.                         state := success;
  540.                         while p <= length(pattern) do begin
  541.                             if pattern[p] <> '*' then begin
  542.                                 state := failed;
  543.                                 leave;
  544.                             end;
  545.                             p := p + 1;
  546.                         end;
  547.                     end;
  548.                     3:  begin
  549.                         case pattern[p] of
  550.                             '?':  begin
  551.                                 p := p + 1;
  552.                                 n := n + 1;
  553.                             end;
  554.                             '*':  begin
  555.                                 p := p + 1;
  556.                                 if p > length(pattern) then begin { short circuit the * at the end case }
  557.                                     state := success;
  558.                                 end else begin
  559.                                     state := failed;
  560.                                     while n <= length(name) do begin
  561.                                         if M(p, n) then begin
  562.                                             state := success;
  563.                                             leave;
  564.                                         end;
  565.                                         n := n + 1;
  566.                                     end;
  567.                                 end;
  568.                             end;
  569.                             otherwise begin
  570.                                 if name[n] <> pattern[p] then begin
  571.                                     state := failed;
  572.                                 end;
  573.                                 n := n + 1;
  574.                                 p := p + 1;
  575.                             end;
  576.                         end;
  577.                     end;
  578.                 end;
  579.             end;
  580.             M := state = success;
  581.         end;
  582.     begin
  583.         UpperString(pattern, false);
  584.         UpperString(name, false);
  585.         Match := M(1, 1);
  586.     end;
  587.  
  588.     procedure LimitStringLength (var s: string; len: integer; delimiter: char);
  589.         var
  590.             p: integer;
  591.     begin
  592.         if length(s) > len then begin
  593.             p := Pos(delimiter, s);
  594.             if p <= 0 then begin
  595.                 p := length(s) div 2 + 1;
  596.                 s[p] := delimiter;
  597.             end;
  598.             while length(s) > len do begin
  599.                 if p > len div 2 + 1 then begin
  600.                     Delete(s, p - 1, 1);
  601.                     p := p - 1;
  602.                 end else begin
  603.                     Delete(s, p + 1, 1);
  604.                 end;
  605.             end;
  606.         end;
  607.     end;
  608.  
  609.     function StringToOSType (const s: Str255): OSType;
  610.         var
  611.             t: OSType;
  612.     begin
  613.         if length(s) >= 4 then begin
  614.             BlockMoveData(@s[1], @t, 4);
  615.         end else begin
  616.             t := OSType(0);
  617.             BlockMoveData(@s[1], @t, length(s));
  618.         end;
  619.         StringToOSType := t;
  620.     end;
  621.  
  622.     function OSTypeToString (t: OSType): Str255;
  623.         var
  624.             s:Str255;
  625.     begin
  626.         s:=concat(nul,nul,nul,nul);
  627.         BlockMoveData(@t,@s[1],4);
  628.         OSTypeToString:=s;
  629.     end;
  630.  
  631. end.
  632.